home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / bdeprov.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  9.7 KB  |  313 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {       BDE Provider                                    }
  6. {                                                       }
  7. {       Copyright (c) 1997 Borland International        }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit BdeProv;
  12.  
  13. interface
  14.  
  15. uses Windows, SysUtils, Classes, DB, DBTables, DSIntf, DBClient, Provider, BDE;
  16.  
  17.  
  18. type
  19.  
  20. { EUpdateError }
  21.  
  22.   EUpdateError = class(EDatabaseError)
  23.   private
  24.     FContext: string;
  25.     FPreviousError: Integer;
  26.   public
  27.     constructor Create(NativeError, Context: string;
  28.       ErrorCode, PrevError: DBIResult);
  29.     property Context: string read FContext;
  30.     property PreviousError: Integer read FPreviousError;
  31.   end;
  32.  
  33. { TProvider }
  34.  
  35.   TResolverResponse = (rrSkip, rrAbort, rrMerge, rrApply, rrIgnore);
  36.   TResolverErrorEvent = procedure(DataSet: TClientDataSet; E: EUpdateError;
  37.     UpdateKind: TUpdateKind; var Response: TResolverResponse) of object;
  38.   TDataRequestEvent = function(Sender: TObject; Input: OleVariant): OleVariant of object;
  39.  
  40.   TProvider = class(TCustomProvider)
  41.   private
  42.     FDataSet: TDBDataSet;
  43.     FDelta: OleVariant;
  44.     FTableParam: string;
  45.     FSQLParam: string;
  46.     FDeltaDS: TClientDataSet;
  47.     FMaxErrors: Integer;
  48.     FFirstPacketSent: Boolean;
  49.     FDataSetActive: Boolean;
  50.     FHitEOF: Boolean;
  51.     FBeforeGetData: TNotifyEvent;
  52.     FAfterGetData: TNotifyEvent;
  53.     FBeforeUpdate: TNotifyEvent;
  54.     FAfterUpdate: TNotifyEvent;
  55.     FOnUpdateError: TResolverErrorEvent;
  56.     FOnDataRequest: TDataRequestEvent;
  57.     function UpdateCallback(iRslt: Integer; iUpdateKind: DSAttr;
  58.       iResAction: dsCBRType; iErrCode: Integer; pErrMessage, pErrContext: PChar;
  59.       pRecUpd, pRecOrg, pRecConflict: Pointer): dsCBRType; stdcall;
  60.     procedure SetParamValues;
  61.   protected
  62.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  63.     function Get_Data: OleVariant; override;
  64.   public
  65.     constructor Create(AOwner: TComponent); override;
  66.     function ApplyUpdates(Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer): OleVariant; override;
  67.     function GetRecords(Count: Integer; out RecsOut: Integer): OleVariant; override;
  68.     function DataRequest(Input: OleVariant): OleVariant; override;
  69.     procedure Reset; override;
  70.     property Data;
  71.     property Provider;
  72.   published
  73.     property Constraints default True;
  74.     property DataSet: TDBDataSet read FDataSet write FDataSet;
  75.     property BeforeGetData: TNotifyEvent read FBeforeGetData write FBeforeGetData;
  76.     property AfterGetData: TNotifyEvent read FAfterGetData write FAfterGetData;
  77.     property BeforeUpdate: TNotifyEvent read FBeforeUpdate write FBeforeUpdate;
  78.     property AfterUpdate: TNotifyEvent read FAfterUpdate write FAfterUpdate;
  79.     property OnDataRequest: TDataRequestEvent read FOnDataRequest write FOnDataRequest;
  80.     property OnUpdateError: TResolverErrorEvent read FOnUpdateError write FOnUpdateError;
  81.   end;
  82.  
  83. implementation
  84.  
  85. uses DBCommon, Forms, StdVCL, BDEConst, ActiveX;
  86.  
  87. type
  88.   TProviderOptions = (poNoUpdate, poConstraints, poFieldOrg, poMetaData);
  89.   TResolverDataSet = class(TClientDataSet); { ! Get rid of this }
  90.  
  91. { EUpdateError }
  92.  
  93. constructor EUpdateError.Create(NativeError, Context: string;
  94.   ErrorCode, PrevError: DBIResult);
  95. begin
  96.   FContext := Context;
  97.   FPreviousError := PrevError;
  98.   inherited Create(NativeError);
  99. end;
  100.  
  101. { TProvider }
  102.  
  103. function CreateProvider(Source: TDBDataSet): IProvider;
  104. begin
  105.   with TProvider.Create(Source) do
  106.     begin
  107.       Result := Provider;
  108.       DataSet := Source;
  109.     end;
  110. end;
  111.  
  112. constructor TProvider.Create(AOwner: TComponent);
  113. begin
  114.   inherited Create(AOwner);
  115.   if AOwner is TDBDataSet then
  116.     FDataSet := TDBDataSet(AOwner);
  117.   Constraints := True;
  118. end;
  119.  
  120. procedure TProvider.Notification(AComponent: TComponent; Operation: TOperation);
  121. begin
  122.   inherited Notification(AComponent, Operation);
  123.   if (Operation = opRemove) and (FDataSet <> nil) and
  124.     (AComponent = FDataSet) then FDataSet := nil;
  125. end;
  126.  
  127. function TProvider.Get_Data: OleVariant;
  128. var
  129.   RecsOut: Integer;
  130. begin
  131.   Result := GetRecords(-1, RecsOut);
  132. end;
  133.  
  134. function TProvider.GetRecords(Count: Integer; out RecsOut: Integer): OleVariant;
  135. var
  136.   DataPacket: PVarArray;
  137.   TempEOF: Bool;
  138.   ProvOpts: set of TProviderOptions;
  139. begin
  140.   if not Assigned(FDataSet) then DatabaseError(SMissingDataSet);
  141.   if Assigned(FBeforeGetData) then FBeforeGetData(Self);
  142.   ProvOpts := [];
  143.   if not FFirstPacketSent then
  144.   begin
  145.     FDataSetActive := FDataSet.Active;
  146.     Include(ProvOpts, poMetaData);
  147.     if Constraints then Include(ProvOpts, poConstraints);
  148.     FHitEOF := False;
  149.     FFirstPacketSent := True;
  150.   end;
  151.   FDataSet.Active := True;
  152.   try
  153.     FDataSet.CheckBrowseMode;
  154.     if FHitEOF then
  155.       DbiSetToEnd(FDataSet.Handle)
  156.     else if (Count = -1) and (poMetaData in ProvOpts) then
  157.       DbiSetToBegin(FDataSet.Handle)
  158.     else
  159.     begin
  160.       FDataSet.UpdateCursorPos;
  161.       DbiGetPriorRecord(FDataSet.Handle, dbiNoLock, nil, nil);
  162.     end;
  163.     RecsOut := Count;
  164.     Check(DsProviderGetDataPacket(FDataSet.Handle, Integer(Byte(ProvOpts)),
  165.       @TDBDataSet.ConstraintCallBack, Integer(FDataset), @RecsOut, DataPacket,
  166.       TempEOF));
  167.     Result := SafeArrayToVariant(DataPacket);
  168.     if (RecsOut <> Count) then Reset else
  169.     begin
  170.       FHitEOF := DbiGetNextRecord(FDataSet.Handle, dbiNoLock, nil, nil) = DBIERR_EOF;
  171.       FDataSet.CursorPosChanged;
  172.       FDataSet.Resync([]);
  173.     end;
  174.   except
  175.     Reset;
  176.   end;
  177.   if Assigned(FAfterGetData) then FAfterGetData(Self);
  178. end;
  179.  
  180. procedure TProvider.Reset;
  181. begin
  182.   if FFirstPacketSent then
  183.   begin
  184.     DataSet.Active := FDataSetActive;
  185.     if Assigned(DataSet) and DataSet.Active then DataSet.First;
  186.     FFirstPacketSent := False;
  187.   end;
  188. end;
  189.  
  190. procedure TProvider.SetParamValues;
  191. var
  192.   Len: Integer;
  193. begin
  194.   if FDataSet is TQuery then
  195.   begin
  196.     FSQLParam := TQuery(FDataSet).SQL.Text;
  197.     FTableParam := '';
  198.   end else if FDataSet is TTable then
  199.   begin
  200.     Len := Length(TTable(FDataSet).TableName);
  201.     if Len > 0 then
  202.     begin
  203.       SetLength(FTableParam, Len);
  204.       AnsiToNative(FDataSet.Locale, TTable(FDataSet).TableName, PChar(FTableParam), Len);
  205.     end;
  206.     FSQLParam := '';
  207.   end;
  208. end;
  209.  
  210. function TProvider.ApplyUpdates(Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer): OleVariant;
  211. var
  212.   Results: PacketList;
  213.   Callback: Pointer;
  214.   Session: TSession;
  215.   FDatabase: TDatabase;
  216.   DeltaList: PacketList;
  217.   Callbacks: CBList;
  218.   ClientData: IntList;
  219.   SQLData: NameList;
  220.   TableData: NameList;
  221.   MoreCB: CBList;
  222. begin
  223.   if not Assigned(FDataSet) then DatabaseError(SMissingDataSet);
  224.   if Assigned(FBeforeUpdate) then FBeforeUpdate(Self);
  225.   SetParamValues;
  226.   FDelta := Delta;
  227.   Session := Sessions.OpenSession(FDataSet.SessionName);
  228.   FDatabase := Session.OpenDatabase(FDataSet.DatabaseName);
  229.   try
  230.     try
  231.       FMaxErrors := MaxErrors;
  232.       ErrorCount := FMaxErrors;
  233.       if Assigned(FOnUpdateError) then
  234.         Callback := @TProvider.UpdateCallback else
  235.         Callback := nil;
  236.       DeltaList[1] := TVarData(FDelta).VArray;
  237.       Callbacks[1] := Callback;
  238.       ClientData[1] := Integer(Self);
  239.       TableData[1] := PChar(FTableParam);
  240.       SQLData[1] := PChar(FSQLParam);
  241.       MoreCB[1] := @TDBDataSet.ConstraintCallBack;
  242.       Check(DsResolver(1, @DeltaList, FDatabase.Handle, nil, nil, nil, @SQLData,
  243.         @TableData, @ClientData, @Callbacks, @MoreCB, Integer(FDataSet),
  244.         @ErrorCount, @Results));
  245.       Result := SafeArrayToVariant(Results[1]);
  246.     finally
  247.       FDelta := NULL;
  248.       FDeltaDS.Free;
  249.       FDeltaDS := nil;
  250.     end;
  251.   finally
  252.     Session.CloseDatabase(FDatabase);
  253.   end;
  254.   if Assigned(FAfterUpdate) then FAfterUpdate(Self);
  255. end;
  256.  
  257. function TProvider.DataRequest(Input: OleVariant): OleVariant;
  258. begin
  259.   if Assigned(FOnDataRequest) then
  260.     Result := FOnDataRequest(Self, Input) else
  261.     Result := NULL;
  262. end;
  263.  
  264. function TProvider.UpdateCallback(
  265.     iRslt         : Integer;   { Previous error message if any }
  266.     iUpdateKind   : DSAttr;    { Update request Insert/Modify/Delete }
  267.     iResAction    : dsCBRType; { Resolver response (Not used here) }
  268.     iErrCode      : Integer;   { Native error-code, (BDE or ..) }
  269.     pErrMessage,               { Native errormessage, if any (otherwise NULL) }
  270.     pErrContext   : PChar;     { 1-level error context, if any (otherwise NULL) }
  271.     pRecUpd,                   { Record that failed update }
  272.     pRecOrg,                   { Original record, if any }
  273.     pRecConflict  : Pointer    { Conflicting record, if any }
  274. ): dsCBRType;
  275. var
  276.   Response: TResolverResponse;
  277.   UpdateKind: TUpdateKind;
  278. begin
  279.   try
  280.     if not Assigned(FDeltaDS) then
  281.     begin
  282.       FDeltaDS := TClientDataSet.Create(Self);
  283.       FDeltaDS.Data := FDelta;
  284.     end;
  285.     TResolverDataSet(FDeltaDS).SetAltRecBuffers(pRecOrg, pRecUpd, pRecConflict);
  286.     if iUpdateKind = dsRecDeleted then
  287.       UpdateKind := ukDelete
  288.     else if iUpdateKind = dsRecNew then
  289.       UpdateKind := ukInsert
  290.     else
  291.       UpdateKind := ukModify;
  292.  
  293.     if FMaxErrors > 0 then
  294.       Response := rrSkip else
  295.       Response := rrAbort;
  296.     try
  297.       raise EUpdateError.Create(pErrMessage, pErrContext, iErrCode, iRslt);
  298.     except
  299.       on E: EUpdateError do
  300.         FOnUpdateError(FDeltaDS, E, UpdateKind, Response);
  301.     end;
  302.   except
  303.     Application.HandleException(Self);
  304.     Response := rrAbort;
  305.   end;
  306.   Result := Ord(Response) + 1;
  307. end;
  308.  
  309. begin
  310.   if not Assigned(CreateProviderProc) then
  311.     CreateProviderProc := CreateProvider;
  312. end.
  313.